home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue50 / Except / LIVCLINT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-30  |  2.4 KB  |  87 lines
  1. // RTLI for VCL. Implements the exception message box that
  2. // gives detailed exception location information
  3.  
  4. unit LIVCLInt;
  5.  
  6. interface
  7.  
  8. procedure RTLIShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  9.  
  10. implementation
  11.  
  12. uses LIPrgInt, SysUtils, Forms, Windows;
  13.  
  14. type
  15.   TExceptionHandlerObject = class
  16.     constructor Create;
  17.     procedure HandleExceptions(Sender: TObject; E: Exception);
  18.   end;
  19.  
  20. var
  21.   PrevInitProc: Pointer;
  22.   ExceptionHandlerObject: TExceptionHandlerObject = nil;
  23.  
  24. procedure RTLIShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  25. var
  26.   LocInfo: TLocInfo;
  27.   Msg,ModuleName: String;
  28.   Buffer: array[0..259] of Char;
  29. begin
  30.   GetLocationInfo(ExceptAddr, LocInfo);
  31.   if ExceptObject is Exception then
  32.     Msg := Exception(ExceptObject).Message
  33.   else
  34.     Msg := '**Unknown**';
  35.   GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
  36.   ModuleName := ExtractFileName(Buffer);
  37.   with LocInfo do
  38.   begin
  39.     if liFileName = '' then
  40.       liFileName := '**Unknown**';
  41.     if liUnitName = '' then
  42.       liUnitName := '**Unknown**';
  43.     Msg := Format('%s'                                + ^J +
  44.                   'Exception address %8.8x'           + ^J +
  45.                   'Module %s, Unit %s, %8.8x - %8.8x' + ^J +
  46.                   'File %s line %d offset %8.8x'      + ^J +
  47.                   'Between %s(%8.8x) and %s(%8.8x)',
  48.       [Msg,
  49.        Integer(ExceptAddr),
  50.        ModuleName, liUnitName, liUnitBegOfs, liUnitEndOfs,
  51.        liFileName, liLineNo, liLineOfs,
  52.        liPubSym1Name, liPubSym1Ofs, liPubSym2Name, liPubSym2Ofs]);
  53.   end;
  54.   MessageBox(0, PChar(Msg), 'Application Error', mb_Ok or mb_IconStop or mb_TaskModal);
  55. end;
  56.  
  57. constructor TExceptionHandlerObject.Create;
  58. begin
  59.   Application.OnException := HandleExceptions;
  60. end;
  61.  
  62. procedure TExceptionHandlerObject.HandleExceptions(Sender: TObject; E: Exception);
  63. begin
  64.   RTLIShowException(E, ExceptAddr);
  65. end;
  66.  
  67. procedure RTLIInitProc;
  68. begin
  69.   ExceptionHandlerObject := TExceptionHandlerObject.Create;
  70.   if Assigned(PrevInitProc) then
  71.     TProcedure(PrevInitProc);
  72. end;
  73.  
  74. procedure RTLIExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer);
  75. begin
  76.   RTLIShowException(ExceptObject, ExceptAddr);
  77.   Halt(1);
  78. end;
  79.  
  80. initialization
  81.   PrevInitProc := InitProc;
  82.   InitProc := @RTLIInitProc;
  83.   ExceptProc := @RTLIExceptHandler;
  84. finalization
  85.   ExceptionHandlerObject.Free;
  86. end.
  87.